www.gusucode.com > 落叶冰点万能企业网站内容管理系统 V9.1 > 落叶冰点万能企业网站内容管理系统 V9.1\code\inc\Collection-b\Admin_ItemCollecSteady.asp

    <%@language=vbscript codepage=936 %>


<%

Response.Buffer = True 
Server.ScriptTimeOut=999
Response.Expires = -1
Response.ExpiresAbsolute = Now() - 1 
Response.Expires = 0 
Response.CacheControl = "no-cache" 
%>
<!--#include file="inc/conn.asp"-->
<!--#include file="inc/function.asp"-->
<!--#include file="Admin_ChkPurview.asp"-->
<!--#include file="inc/ubbcode.asp"-->
<!--#include file="inc/clsCache.asp"-->
<%
Dim ItemNum,ListNum,ListSuccesNum,ListFalseNum,NewsNumAll
Dim Rs,Sql,RsItem,SqlItem,FoundErr,ErrMsg,ItemEnd,ListEnd

'项目变量
Dim ItemID,ItemName,LoginType,LoginUrl,LoginPostUrl,LoginUser,LoginPass,LoginFalse
Dim ListStr,LsString,LoString,ListPaingType,LPsString,LPoString,ListPaingStr1,ListPaingStr2,ListPaingID1,ListPaingID2,ListPaingStr3,HsString,HoString,HttpUrlType,HttpUrlStr,CollecListNum,CollecNewsNum

'采集相关的变量
Dim Arr_i,NewsUrl

'其它变量
Dim LoginData,LoginResult
Dim Arr_Item,CacheTemp,CollecOrder,OrderTemp

'执行时间变量
Dim StartTime,OverTime

'列表
Dim ListUrl,ListCode,NewsArrayCode,NewsArray,ListArray,ListPaingNext,ListPaingTemp

CacheTemp=Lcase(trim(request.ServerVariables("SCRIPT_NAME")))
CacheTemp=left(CacheTemp,instrrev(CacheTemp,"/"))
CacheTemp=replace(CacheTemp,"\","_")
CacheTemp=replace(CacheTemp,"/","_")
CacheTemp="ansir" & CacheTemp

ItemNum=Clng(Trim(Request("ItemNum")))
ListNum=Clng(Trim(Request("ListNum")))
ListSuccesNum=Clng(Trim(Request("ListSuccesNum")))
ListFalseNum=Clng(Trim(Request("ListFalseNum")))
NewsNumAll=Clng(Trim(Request("NewsNumAll")))
ListPaingNext=Trim(Request("ListPaingNext"))

FoundErr=False
ItemEnd=False
ListEnd=False
CollecListNum=0
CollecNewsNum=0

Call SetCache()

If ItemEnd<>True Then
   If (ItemNum-1)>Ubound(Arr_Item,2) then
      ItemEnd=True
   Else
      Call SetItems()
   End If
End If

If ItemEnd<>True Then
   If ListPaingType=0 Then
      If ListNum=1 Then
         ListUrl=ListStr
      Else
         ListEnd=True
      End If
   ElseIf ListPaingType=1 Then
      If ListNum=1 Then
         ListUrl=ListStr
      Else
         If ListPaingNext="" or ListPaingNext="$False$" Then
            ListEnd=True
         Else
            ListPaingNext=Replace(ListPaingNext,"{$ID}","&")
            ListUrl=ListPaingNext
         End If
      End If
   ElseIf ListPaingType=2 Then
      If ListPaingID1>ListPaingID2 then
         If (ListPaingID1-ListNum+1)<ListPaingID2 or (ListPaingID1-ListNum+1)<0 Then
            Listend=True
         Else
            ListUrl=Replace(ListPaingStr2,"{$ID}",Cstr(ListpaingID1-ListNum+1))
         End if
      Else
         If (ListPaingID1+ListNum-1)>ListPaingID2 Then
            ListEnd=True
         Else
            ListUrl=Replace(ListPaingStr2,"{$ID}",CStr(ListPaingID1+ListNum-1))
         End If
      End If      
   ElseIf ListPaingType=3  Then
      ListArray=Split(ListPaingStr3,"|")
      If (ListNum-1)>Ubound(ListArray) Then
         ListEnd=True
      Else
         ListUrl=ListArray(ListNum-1)
      End If    
   End If
   If ListNum>CollecListNum And CollecListNum<>0 Then
      ListEnd=True
   End if
End If

If ItemEnd=True Then
   ErrMsg="<br>列表分析完成"
   ErrMsg=ErrMsg & "<br>成功分析： "  &  ListSuccesNum  &  "  页列表,失败： "    &  ListFalseNum  &  "  页,新闻：" & NewsNumAll & "  条"
   ErrMsg=ErrMsg& "<br>正在整理数据，稍后进行新闻的采集..."
   ErrMsg=ErrMsg & "<meta http-equiv=""refresh"" content=""3;url=Admin_ItemCollecNews.asp?ItemNum=1&NewsNum=1&NewsSuccesNum=0&NewsFalseNum=0&ImagesNumAll=0&NewsNumAll=" & NewsNumAll & """>"
Else
   If ListEnd=True Then
      ItemNum=ItemNum+1
      ListNum=1
      ErrMsg="<br>" & ItemName & "  项目所有列表分析完成，正在整理数据请稍后..."
      ErrMsg=ErrMsg & "<meta http-equiv=""refresh"" content=""3;url=Admin_ItemCollecSteady.asp?ItemNum=" & ItemNum & "&ListNum=" & ListNum & "&ListSuccesNum=" & ListSuccesNum & "&ListFalseNum=" & ListFalseNum & "&NewsNumAll=" & NewsNumAll & """>"
   End If
End If

Call TopItem()
If ItemEnd<>True And ListEnd<>True Then
   FoundErr=False
   ErrMsg=""
   Call StartCollection()
End  If

Call WriteSucced(ErrMsg)
Call FootItem()
Response.Flush()
'关闭数据库链接
Call CloseConn()
Call CloseConnItem()
%>

<%
'==================================================
'过程名：StartCollection
'作  用：开始采集
'参  数：无
'==================================================
Sub StartCollection

'第一次采集时登录
If LoginType=1 And ListNum=1 then
   LoginData=UrlEncoding(LoginUser & "&" & LoginPass)
   LoginResult=PostHttpPage(LoginUrl,LoginPostUrl,LoginData)
   If Instr(LoginResult,LoginFalse)>0 Then
      FoundErr=True
      ErrMsg=ErrMsg & "<br><li>在登录网站时发生错误，请确保登录信息的正确性！</li>"
   End If
End If


If FoundErr<>True then
   ListCode=GetHttpPage(ListUrl)
   Call GetListPaing()
   If ListCode="$False$" Then
      FoundErr=True
      ErrMsg=ErrMsg & "<br><li>在获取列表：" & ListUrl & "网页源码时发生错误！</li>"
   Else
      ListCode=GetBody(ListCode,LsString,LoString,False,False)
      If ListCode="$False$" Or ListCode="" Then
         FoundErr=True
         ErrMsg=ErrMsg & "<br><li>在截取：" & ListUrl & "的新闻列表时发生错误！</li>"
      End If
   End If
End If

If FoundErr<>True Then
   NewsArrayCode=GetArray(ListCode,HsString,HoString,False,False)
   If NewsArrayCode="$False$" Then
      FoundErr=True
      ErrMsg=ErrMsg & "<br><li>在分析：" & ListUrl & "新闻列表时发生错误！</li>"
   Else
      NewsArray=Split(NewsArrayCode,"$Array$")
      For Arr_i=0 to Ubound(NewsArray)
         If HttpUrlType=1 Then
            NewsArray(Arr_i)=Trim(Replace(HttpUrlStr,"{$ID}",NewsArray(Arr_i)))
         Else
            NewsArray(Arr_i)=Trim(DefiniteUrl(NewsArray(Arr_i),ListUrl))           
         End If
         NewsArray(Arr_i)=CheckUrl(NewsArray(Arr_i))
      Next
      If CollecOrder=True Then
         For Arr_i=0 to Fix(Ubound(NewsArray)/2)
            OrderTemp=NewsArray(Arr_i)
            NewsArray(Arr_i)=NewsArray(Ubound(NewsArray)-Arr_i)
            NewsArray(Ubound(NewsArray)-Arr_i)=OrderTemp
         Next
      End If
   End If
End If

If FoundErr<>True Then
   ErrMsg=ErrMsg & "<br>本次运行 " & Ubound(Arr_Item,2)+1 & " 个项目"
   ErrMsg=ErrMsg & "<br>从第 " & ItemNum  & " 个项目 " & ItemName & " 的第 "  & ListNum & " 页列表分析出 " & Ubound(NewsArray) & " 条新闻"
   If CollecNewsNum<>0 Then
      ErrMsg=ErrMsg & "，限制 " & CollecNewsNum & " 条。"
      If (CollecNewsNum-1)>Ubound(NewsArray) Then
         CollecNewsNum=Ubound(NewsArray)+1
      Else
         '保持不变CollecNewsNum
      End If
   Else
      CollecNewsNum=Ubound(NewsArray)+1
   End If
   ListSuccesNum=ListSuccesNum+1
   NewsNumAll=NewsNumAll+CollecNewsNum
   Call SaveNewsList()
Else
   ListFalseNum=ListFalseNum+1
End If
ErrMsg=ErrMsg & "<br>" & "<meta http-equiv=""refresh"" content=""3;url=Admin_ItemCollecSteady.asp?ItemNum=" & ItemNum & "&ListNum=" & ListNum+1 & "&ListSuccesNum=" & ListSuccesNum & "&ListFalseNum=" & ListFalseNum & "&NewsNumAll=" & NewsNumAll & "&ListPaingNext=" & ListPaingNext  & """>"

End Sub


'==================================================
'过程名：SetCache
'作  用：存取缓存
'参  数：无
'==================================================
Sub SetCache()
   Dim myCache
   Set myCache=new clsCache

   '项目信息
   myCache.name=CacheTemp & "items"
   If myCache.valid then 
      Arr_Item=myCache.value
   Else
      ItemEnd=True
   End If
   Set myCache=Nothing
End Sub

Sub SetItems() 
      Dim ItemNumTemp
      ItemNumTemp=ItemNum-1
      ItemID=Arr_Item(0,ItemNumTemp)
      ItemName=Arr_Item(1,ItemNumTemp)
      LoginType=Arr_Item(9,ItemNumTemp)
      LoginUrl=Arr_Item(10,ItemNumTemp)          '登录
      LoginPostUrl=Arr_Item(11,ItemNumTemp)
      LoginUser=Arr_Item(12,ItemNumTemp)
      LoginPass=Arr_Item(13,ItemNumTemp)
      LoginFalse=Arr_Item(14,ItemNumTemp)
      ListStr=Arr_Item(15,ItemNumTemp)            '列表地址
      LsString=Arr_Item(16,ItemNumTemp)          '列表
      LoString=Arr_Item(17,ItemNumTemp)
      ListPaingType=Arr_Item(18,ItemNumTemp)
      LPsString=Arr_Item(19,ItemNumTemp)          
      LPoString=Arr_Item(20,ItemNumTemp)
      ListPaingStr1=Arr_Item(21,ItemNumTemp)
      ListPaingStr2=Arr_Item(22,ItemNumTemp)
      ListPaingID1=Arr_Item(23,ItemNumTemp)
      ListPaingID2=Arr_Item(24,ItemNumTemp)
      ListPaingStr3=Arr_Item(25,ItemNumTemp)
      HsString=Arr_Item(26,ItemNumTemp)  
      HoString=Arr_Item(27,ItemNumTemp)
      HttpUrlType=Arr_Item(28,ItemNumTemp)
      HttpUrlStr=Arr_Item(29,ItemNumTemp)
      CollecListNum=Arr_Item(80,ItemNumTemp)
      CollecNewsNum=Arr_Item(81,ItemNumTemp)
      CollecOrder=Arr_Item(84,ItemNumTemp)
End Sub

'==================================================
'过程名：GetListPaing
'作  用：获取列表下一页
'参  数：无
'==================================================
Sub GetListPaing()
   If ListPaingType=1 Then
      ListPaingNext=GetPaing(ListCode,LPsString,LPoString,False,False)
      ListPaingNext=FpHtmlEnCode(ListPaingNext)
      If ListPaingNext<>"$False$" And ListPaingNext<>"" Then
         If ListPaingStr1<>""  Then  
            ListPaingNext=Replace(ListPaingStr1,"{$ID}",ListPaingNext)
         Else
            ListPaingNext=DefiniteUrl(ListPaingNext,ListUrl)
         End If
         ListPaingNext=Replace(ListPaingNext,"&","{$ID}")
      End If
   Else
      ListPaingNext="$False$"
   End If
End Sub

'==================================================
'过程名：SaveNewsList
'作  用：保存文章
'参  数：无
'==================================================
Sub SaveNewsList
   set rs=server.createobject("adodb.recordset")
   sql="select top 1 * from NewsList" 
   rs.open sql,connItem,1,3
   For Arr_i=1 To CollecNewsNum
      rs.addnew
      rs("ItemID")=ItemID
      rs("NewsUrl")=NewsArray(Arr_i-1)
      rs.update
   Next
   rs.close
   set rs=nothing
End Sub

'==================================================
'过程名：TopItem
'作  用：显示导航信息
'参  数：无
'==================================================
Sub TopItem()%>
<html>
<head>
<title>新闻采集系统</title>
<meta http-equiv="Content-Type" content="text/html; charset=gb2312">
<link rel="stylesheet" type="text/css" href="Admin_Style.css">
</head>
<body leftmargin="0" topmargin="0" marginwidth="0" marginheight="0">
<table width="100%" border="0" align="center" cellpadding="0" cellspacing="1" class="border">
  <tr> 
    <td height="22" colspan="2" align="center" class="topbg"><strong>采 集 系 统 采 集 管 理</strong></td>
  </tr>
</table>
<table width="100%" border="0" align="center" cellpadding="0" cellspacing="1" class="border">
  <tr class="tdbg"> 
    <td width="65" height="30"><strong>管理导航：</strong></td>
    <td height="30"><a href="Admin_ItemStart.asp">管理首页</a> >> 列表分析</td>         
  </tr>  
</table>
<table width="100%" border="0" align="center" cellpadding="0" cellspacing="1" class="border">       
  <tr> 
    <td height="22" colspan="2" class="tdbg" aling="center">采集需要一定的时间，请耐心等待，如果网站出现暂时无法访问的情况这是正常的，采集正常结束后即可恢复。
    </td>
  </tr>
</table>
<%End Sub%>

<%
'==================================================
'过程名：FootItem
'作  用：显示底部版权等信息
'参  数：无
'==================================================
Sub FootItem()%>
<!--#include file="Admin_ItemFoot.asp"-->       
</body>         
</html>
<%End Sub%>